home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / set.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-06-18  |  3.2 KB  |  126 lines
  1. /* ******************************************************************** */
  2. /*  set.c            Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /*  support for "set"                                                   */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, May 1989
  10.  * 
  11.  *   Had to add a new function to get it to work on anoymous functions
  12.  *                                                      (16/11/89) KJP
  13.  */
  14.  
  15. #include "defs.h"
  16. #include "structs.h"
  17. #include "funcalls.h"
  18.  
  19. #include "error.h"
  20. #include "global.h"
  21. #include "class.h"
  22. #include "ngenerics.h"
  23.  
  24. /* Global table of relations... */
  25.  
  26. LispObject set_lookup_table;
  27.  
  28. /* accepts a function or a name of a function */
  29.  
  30. EUFUN_1( Fn_setter, func)
  31. {
  32.   LispObject setter = func,ans;
  33.   int bool;
  34.  
  35.   while (TRUE) {
  36.     STACK_TMP(setter);
  37.     bool = is_function(setter);
  38.     UNSTACK_TMP(setter);
  39.     if (bool || is_generic(setter)) break;
  40.     setter =
  41.       CallError(stacktop,
  42.         "setter: non-function supplied",ARG_0(stackbase),CONTINUABLE);
  43.   } 
  44.  
  45.   EUCALLSET_2(ans, Fn_tref,set_lookup_table,setter);
  46.  
  47.   if (null(ans))
  48.     signal_message(stacktop, NO_UPDATE_FUNCTION,
  49.            "setter: no updator for function",ARG_0(stackbase));
  50.  
  51.   return(ans);
  52. }
  53. EUFUN_CLOSE
  54.  
  55. /* associate the updator with the function func: both are ids */
  56.  
  57. void set_associate(LispObject *stacktop, LispObject func,LispObject updator)
  58. {
  59.   EUCALL_3(tref_updator, set_lookup_table, 
  60.               func->SYMBOL.lvalue,updator->SYMBOL.lvalue);
  61. }
  62.  
  63. /* as above for function objects */
  64.  
  65. void set_anon_associate(LispObject *stacktop, LispObject get,LispObject set)
  66. {
  67.   EUCALL_3(tref_updator,set_lookup_table,get,set);
  68. }
  69.  
  70. /* make the updator of the function func be "updator" */
  71.  
  72. EUFUN_2( set_updator, func, updator)
  73. {
  74.   LispObject old;
  75.   int bool;
  76.  
  77.   while (TRUE) {
  78.     bool = is_function(func);
  79.     func = ARG_0(stackbase);
  80.     if (bool || is_generic(func)) break;
  81.     func 
  82.       = CallError(stacktop,
  83.           "(setter setter): can't associate setter with non-function",
  84.           ARG_0(stackbase),CONTINUABLE);
  85.     ARG_0(stackbase) = func;
  86.   } 
  87.  
  88.   updator = ARG_1(stackbase);
  89.   while (TRUE) {
  90.     bool = is_function(updator);
  91.     updator = ARG_1(stackbase);
  92.     if ( bool || is_generic(updator)) break;
  93.     updator 
  94.       = CallError(stacktop,
  95.           "(setter setter): prospective associate not a function",
  96.           ARG_1(stackbase),CONTINUABLE);
  97.     ARG_1(stackbase) = updator;
  98.   } 
  99.  
  100.   func = ARG_0(stackbase);
  101.   ARG_0(stacktop) = set_lookup_table;
  102.   ARG_1(stacktop) = func;
  103.   if ((old = Fn_tref(stacktop)) != nil)
  104.     CallError(stacktop,
  105.           "(setter setter): a setter already exists",
  106.           ARG_0(stackbase),NONCONTINUABLE);
  107.  
  108.   set_anon_associate(stacktop, ARG_0(stackbase),ARG_1(stackbase));
  109.  
  110.   return ARG_1(stackbase);    /* updator */
  111. }
  112. EUFUN_CLOSE
  113.  
  114. void initialise_set(LispObject *stacktop)
  115. {
  116.   LispObject fun,upd;
  117.  
  118.   set_lookup_table = (LispObject) allocate_table(stacktop, Fn_eq);
  119.   add_root(&set_lookup_table);
  120.   fun = make_module_function(stacktop,"setter",Fn_setter,1);
  121.   STACK_TMP(fun);
  122.   upd = make_module_function(stacktop,"(setter setter)",set_updator,2);
  123.   UNSTACK_TMP(fun);
  124.   set_anon_associate(stacktop,fun,upd);
  125. }
  126.